home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
L' Effet Pommier 3
/
L'Effet Pommier - Volume 03.iso
/
Programmation
/
Alpha ƒ
/
Tcl
/
SystemCode
/
modes.tcl
< prev
next >
Wrap
Text File
|
1996-01-23
|
19KB
|
805 lines
# (nowrap)
# New modes can be specified by appending to the following vars. (nowrap)
# are no longer any procs such as 'setTextMode' etc.
# 'mode' is nothing when we start up.
set mode {}
set reverting {}
#================================================================================
# The next two procs are called by Alpha to handle the mode flags popup menu.
#================================================================================
proc getModeValuesAlpha {} {
getWinInfo blah
lappend m "Mac" [expr {$blah(platform) == "mac"}]
lappend m "UNIX" [expr {$blah(platform) == "unix"}]
lappend m "IBM" [expr {$blah(platform) == "ibm"}] {(-} 0
lappend m "MPW" [expr {$blah(state) == "mpw"}]
lappend m "Think" [expr {$blah(state) == "think"}]
lappend m "None" [expr {$blah(state) == "none"}] {(-} 0
lappend m "Read Only" $blah(read-only) {(-} 0
lappend m "Tab Size" 0
return $m
}
proc setModeVarAlpha {var} {
global mode allFlags modeVars modifiedModeVars
global ${mode}modeVars
set var [string tolower $var]
switch $var {
"unix" -
"mac" -
"ibm" { setWinInfo platform $var }
"mpw" -
"think" -
"none" { setWinInfo state $var }
"tab size" {
getWinInfo arr
if {![catch {prompt "New tab size?" $arr(tabsize)} res]} {
setWinInfo tabsize $res
}
}
"read only" {
getWinInfo b
setWinInfo read-only [expr -1 * ($b(read-only) - 1)]}
}
return
}
proc modeMenuProc {menu var} {
if {![llength [winNames]]} {
alertnote "No window!"
return
}
switch $var {
"flags" modifyModeFlags
"menus" setModeMenus
"editPrefs" editCurrentModePrefs
"loadPrefs" sourceCurrentModePrefs
"describeMode" describeMode
}
}
#================================================================================
# Suffixes used to initially determine mode for new window.
set modeSuffixes { default { set winMode Text } }
# The set of menus that the modes may choose to use.
set allModeMenus { thinkMenu cwarriorMenu toolserverMenu
latexMenu thinkRefMenu toolboxRefMenu tclMenu perlMenu }
set modeVars { }
# The dummy proc for a mode is called whenever we change to that mode,
# so that the autoloading facility will load the correct file, if
# necessary.
# The list of modes.
set modes {}
set lastMode 0
# Can be used to add new mode-specific flags and variables (see think.tcl for example).
proc newModeVar {mode var val isFlag} {
global ${mode}modeVars modeVars allFlags $var
if {![info exists modeVars] || [lsearch $modeVars $var] < 0} {
lappend modeVars $var
}
if {![info exists ${mode}modeVars($var)]} {
set ${mode}modeVars($var) $val
if {![info exists $var]} {
set $var $val
}
}
if {$isFlag && (![info exists allFlags] || ([lsearch $allFlags $var] < 0))} {
lappend allFlags $var
}
}
#===============================================================================
#================================================================================
if {!$alphaLite} {
source "$HOME:Tcl:SystemCode:modeDefs.tcl"
}
set tcl_var_procs(stringColor) "stringColorProc"
set tcl_var_procs(commentColor) "stringColorProc"
set tcl_var_procs(keywordColor) "stringColorProc"
set tcl_var_procs(sectionColor) "stringColorProc"
set tcl_var_procs(bracesColor) "stringColorProc"
proc stringColorProc {flag} {
global $flag mode
if {[set $flag] == "none"} {
set $flag "foreground"
}
if {$flag == "stringColor"} {
regModeKeywords -a -s $stringColor $mode
} elseif {$flag == "commentColor"} {
regModeKeywords -a -c $commentColor $mode
} elseif {$flag == "bracesColor"} {
regModeKeywords -a -I $bracesColor $mode
} elseif {($flag == "keywordColor") || ($flag == "sectionColor")} {
alertnote "Change in keyword color will take effect after Alpha restarts."
return
}
centerRedraw
}
#================================================================================
proc saveVarValues {} {
global modes HOME
if {[askyesno "Save variables and values to \"$HOME:alphaFlags.tcl\"?"] == "yes"} {
set lines {}
foreach m $modes {
global ${m}modeVars
if {[info exists ${m}modeVars]} {
foreach v [array names ${m}modeVars] {
append lines "set ${m}modeVars($v)\t\t\{[set ${m}modeVars($v)]\}\r"
}
append lines "\r"
}
}
append lines "\r\r"
global allFlags allVars
set vars [lsort [concat $allFlags $allVars]]
eval global $vars
foreach f $vars {
append lines "set $f\t\t\{[set $f]\}\r"
}
set fd [open "$HOME:alphaFlags.tcl" "w"]
puts $fd $lines
close $fd
message "New '$HOME:alphaFlags.tcl' written."
}
}
#================================================================================
proc setWinMode name {
global winModes modeSuffixes
set nm [file tail $name]
if {[set first [string last " <" $nm]] >= 0} {
set rname [string range $nm 0 [expr $first - 1]]
} else {
set rname $nm
}
case $rname in $modeSuffixes
set winModes($name) $winMode
}
proc newMode mode {
global winModes modeProcs
set name [lindex [winNames -f] 0]
changeMode $mode
set winModes($name) $mode
centerRedraw
}
proc deactivateHook name {
}
proc suspendHook name {
global iconifyOnSwitch
global suspIconed
if {$iconifyOnSwitch} {
set wins [winNames -f]
set suspIconed ""
foreach win $wins {
if {![icon -f "$win" -q]} {
lappend suspIconed $win
icon -f "$win" -t
}
}
set suspIconed [lreverse $suspIconed]
}
}
set killCompilerErrors 0
proc resumeHook name {
global iconifyOnSwitch resumeRevert suspIconed killCompilerErrors
if {$killCompilerErrors} {
set wins [winNames -f]
if {[set res [lsearch $wins "*Compiler Errors*"]] >= 0} {
bringToFront [lindex $wins $res]
killWindow
}
}
if {$iconifyOnSwitch && [info exists suspIconed]} {
set wins [winNames -f]
foreach win $suspIconed {
icon -f "$win" -o
}
unset suspIconed
}
if {$resumeRevert} {
set resumeRevert 0
revert
}
}
# Handles dynamically adding and deleting window names from menu.
proc addWinName name {
global winNameToNum winMenu winNumToName
for {set i 0} {$i<100} {incr i} {
if {[catch {set nm $winNumToName($i)} res] == "1"} {
regexp {[^:]*$} $name nm
if {$i < 10} {
addMenuItem -m -l "/$i" $winMenu $nm
} else {
addMenuItem -m -l "" $winMenu $nm
}
set winNumToName($i) $name
set winNameToNum($name) $i
return
}
}
}
proc removeWinName name {
global winNameToNum winNumToName winMenu
set num $winNameToNum($name)
unset winNumToName($num)
unset winNameToNum($name)
regexp {[^:]*$} $name nm
deleteMenuItem -m $winMenu $nm
}
proc menuWin {menu name} {
global winNameToNum
set nms [array names winNameToNum]
if {[lsearch $nms "*$name"] < 0} {
$name
return
}
foreach nm $nms {
if {[string match *$name $nm] == "1"} {
bringToFront $name
if [icon -q] { icon -f $name -o }
return
}
}
return "normal"
}
# Do not move 'displayMode' calls!
proc changeMode {newMode} {
global lastMode modeMenus dummyProc mode seenMode PREFS
set lastMode $mode
set mode $newMode
if {$lastMode == $mode} {
catch {displayMode $newMode}
return
}
# Used to be after the modeVar stuff. Why?
if {[info exists dummyProc($mode)]} { $dummyProc($mode) }
global ${mode}modeVars
if {[info exists ${mode}modeVars]} {
foreach v [array names ${mode}modeVars] {
global $v
set $v [set ${mode}modeVars($v)]
}
}
if {[info exists modeMenus($lastMode)]} {
foreach m $modeMenus($lastMode) {
global $m
catch {removeMenu [set $m]}
}
}
if {[info exists modeMenus($mode)]} {
foreach m $modeMenus($mode) {
catch {$m}
global $m
catch {insertMenu [set $m]}
}
}
if {![info exists seenMode($mode)]} {
if {[file exists "$PREFS:${mode}Prefs.tcl"]} {
source "$PREFS:${mode}Prefs.tcl"
}
set seenMode($mode) 1
}
catch {displayMode $newMode}
}
proc setModeMenus {} {
global mode modeMenus allModeMenus modifiedModeMenus
set menus [listpick -p "Pick menus for mode '$mode':" -l -L $modeMenus($mode) [lsort $allModeMenus]]
set modeMenus($mode) $menus
lappend modifiedModeMenus $mode
foreach m $allModeMenus {
global $m
catch {removeMenu [set $m]}
}
foreach m $menus {
global $m
catch {$m}
catch {insertMenu [set $m]}
}
}
#=============================================================================
# Hook procs recognized: "openHook", "closeHook", "activateHook", "deactivateHook",
# "suspendHook", "saveasHook", "saveHook", and "resumeHook".
#=============================================================================
if {![info exists winActive]} {set winActive ""}
# Event hooks - set specific modes when files opened.
proc openHook name {
global winModes autoMark mode screenHeight screenWidth forceMainScreen recentFiles recentFilesCount
changeMode $winModes($name)
if {$name == {*Toolserver shell*}} startMPW
addWinName $name
message ""
if {![catch {getFileInfo $name info}]} {
if {$info(creator) == {ttxt}} {
setWinInfo dirty 0
}
if {$info(type) == {ttro}} {
catch {setWinInfo read-only 1}
message "Read-only!"
}
}
global ${mode}modeVars
if {$forceMainScreen} {
set geo [getGeometry]
set l [lindex $geo 0]; set t [lindex $geo 1]; set w [lindex $geo 2]; set h [lindex $geo 3];
if {($l < 0) || ($t < 35) || ([expr $l + $w] > $screenWidth) || ([expr $t + $h + 18] > $screenHeight)} {
singlePage
}
}
getWinInfo arr
if {[info exists ${mode}modeVars(autoMark)] && [set ${mode}modeVars(autoMark)] && !$arr(read-only) && ![llength [getNamedMarks -n]]} {
markFile
}
if {[string match "*Preferences*defs.tcl" $name]} {setWinInfo read-only 1}
pushRecent $name
}
# full pathname
proc saveHook name {
global backup backExtension backDir mode
if {($mode == "C") || ($mode == "C++")} {catch {modified}}
if ($backup) {
if {![string length [set dir $backDir]]} {
set dir [file dirname $name]
}
if {![file exists $dir]} {
if {[askyesno "Create backup dir '$dir'?"] == "yes"} {
mkdir $dir
}
}
catch {rm $dir:[file tail $name]$backExtension}
catch {cp $name $dir:[file tail $name]$backExtension}
}
}
proc revertToBackup {} {
global backup backExtension backDir winModes
set fname [lindex [winNames -f] 0]
set bname "$backDir:[file tail $fname]$backExtension"
if {![file exists $bname]} {
message "Backup file '$bname' does not exist"
return
}
if {[askyesno "Revert to backup dated '[join [mtime [file mtime $bname]]]'?"] == "yes"} {
killWindow
edit $bname
saveAs -f $fname
}
}
# Clean up the mark stack.
proc closeHook name {
global markStack winModes winActive
unset winModes($name)
if [llength $markStack] {
set markStack [removePat $markStack $name*]
}
removeWinName $name
if {[set ind [lsearch $winActive $name]] >= 0} {
set winActive [lreplace $winActive $ind $ind]
}
catch {unset winModes($name)}
}
proc saveasHook {oldName newName} {
global winModes winActive
removeWinName $oldName
addWinName $newName
setWinMode $newName
changeMode $winModes($newName)
pushRecent $newName
if {[set ind [lsearch $winActive $oldName]] >= 0} {
set winActive [lreplace $winActive $ind $ind]
}
set winActive [linsert $winActive 0 $newName]
catch {unset winModes($oldName)}
}
if {![info exists actives]} {set actives 0}
# and, install a new 'winActive' patch , to 'activateHook':
proc activateHook name {
global winModes winActive
if {![info exists winModes($name)]} {
setWinMode $name
}
changeMode $winModes($name)
if {[set ind [lsearch $winActive $name]] == -1} {
set winActive [linsert $winActive 0 $name]
return
}
if {$ind >= 1} {
set winActive [lreplace $winActive $ind $ind]
set winActive [linsert $winActive 0 $name]
}
}
proc dirtyHook {name dirty} {
global winMenu
markMenuItem $winMenu [file tail $name] $dirty "╫"
}
set modifiedVars {}
set modifiedArrVars {}
set modifiedModeVars {}
set modifiedModeMenus {}
proc quitHook {} {
global quitHooks
saveModifiedVars
if {[info exists quitHooks]} {
foreach item $quitHooks {
$item
}
}
}
proc saveModifiedVars {} {
global modifiedVars modifiedModeVars modifiedArrVars modifiedModeMenus modeMenus prefDefs recentFilesSave recentFiles
if {[llength $modifiedVars] || [llength $modifiedArrVars] || [llength $modifiedModeVars] || [llength $modifiedModeMenus]} {
foreach f [removeDups $modifiedModeMenus] {
addArrDef modeMenus $f $modeMenus($f)
}
foreach f [removeDups $modifiedArrVars] {
global $f
foreach ind [array names $f] {
addArrDef $f $ind [set ${f}($ind)]
}
}
foreach f [removeDups $modifiedVars] {
global $f
addDef $f [set $f]
}
foreach f [removeDups $modifiedModeVars] {
set nm [lindex $f 0]
set mode [lindex $f 1]
global $mode
addArrDef [set mode] $nm [set [set mode]($nm)]
}
}
if {[info exists recentFiles]} {
addDef recentFilesSave $recentFiles
}
set modifiedVars {}
set modifiedArrVars {}
set modifiedModeVars {}
set modifiedModeMenus {}
}
#================================================================================
proc describeMode {} {
global mode modeSuffixes modeMenus modes
global ${mode}modeVars
set text "\r\tMODE $mode\r\r"
set suffs ""
set first 1
foreach suf $modeSuffixes {
if {([llength $suf] == 3) && ([lindex $suf 1] == "winMode") && ([lindex $suf 2] == $mode)} {
if {$first} {
lappend suffs $last
set first 0
} else {
append suffs ", $last"
}
}
set last $suf
}
append text "Mode suffixes: $suffs\r\r"
set first 1
append text "Mode menus: "
if {[info exists modeMenus($mode)]} {
foreach m $modeMenus($mode) {
if $first {
set first 0
lappend text $m
} else {
append text ", $m"
}
}
}
append text "\r\r"
append text "Mode-specific variables:\r"
if {[info exists ${mode}modeVars]} {
foreach v [lsort [array names ${mode}modeVars]] {
append text [format "\t%-20s: \"%s\"\r" $v [set ${mode}modeVars($v)]]
}
}
set etext "\rMode-independent bindings:\r"
append text "\rMode-specific bindings:\r"
foreach b [split [bindingList] "\r"] {
set lst [lindex $b end]
if {$lst == $mode} {
append text "\t$b\r"
} elseif {[lsearch $modes $lst] < 0} {
append etext "\t$b\r"
}
}
new -n "* <$mode> MODE *"
insertText $text$etext
goto 0
setWinInfo dirty 0
}
#================================================================================
lappend modes Text
set modeMenus(Text) { }
newModeVar Text leftFillColumn {0} 0
newModeVar Text suffixString { <--} 0
newModeVar Text prefixString {> } 0
newModeVar Text fillColumn {75} 0
newModeVar Text wordWrap {1} 1
newModeVar Text wordBreak {[a-zA-Z0-9_]+} 0
newModeVar Text wordBreakPreface {([^a-zA-Z0-9_])} 0
newModeVar Text wrapBreak {[a-zA-Z0-9_]+} 0
newModeVar Text wrapBreakPreface {([^a-zA-Z0-9_])} 0
newModeVar Text autoMark 0 1
#===============================================================================
set flagPrefs(Backups) {backup}
set varPrefs(Backups) {backDir backExtension}
set flagPrefs(Gui) { blinkingCursor blockCursor coloring dragAndDrop iconifyOnSwitch intelCutPaste lockStatus showEudoraMenu showInvisibles }
set varPrefs(Gui) {defaultFont fontSize tabSize}
set flagPrefs(Printer) {printHeader printHeaderFullPath printHeaderTime}
set varPrefs(Printer) {bottomMargin printerFont printerFontSize topMargin leftMargin}
set flagPrefs(Tags) {}
set varPrefs(Tags) {funcPar tagFile}
set flagPrefs(Window) {autoHScroll forceMainScreen horScrollBar moveInsertion powerThumb sortedIsDefault}
set varPrefs(Window) {defHeight defLeft defTop defWidth horMargin }
set flagPrefs(Tiling) {}
set varPrefs(Tiling) {numWinsToTile tileHeight tileLeft tileMargin tileTop tileWidth }
set flagPrefs(Wrapping) {}
set varPrefs(Wrapping) {paraColumn wrapLow wrapHigh}
set flagPrefs(Miscellaneous) {}
foreach f $allFlags {
if {([lsearch $modeVars $f] < 0) && ([lsearch $flagPrefs(Tiling) $f] < 0) && ([lsearch $flagPrefs(Backups) $f] < 0) && ([lsearch $flagPrefs(Gui) $f] < 0) && ([lsearch $flagPrefs(Printer) $f] < 0) && ([lsearch $flagPrefs(Tags) $f] < 0) && ([lsearch $flagPrefs(Window) $f] < 0) && ([lsearch $flagPrefs(Wrapping) $f] < 0)} {
lappend flagPrefs(Miscellaneous) $f
}
}
set varPrefs(Miscellaneous) {}
foreach f $allVars {
if {([lsearch $modeVars $f] < 0) && ([lsearch $varPrefs(Tiling) $f] < 0) && ([lsearch $varPrefs(Backups) $f] < 0) && ([lsearch $varPrefs(Gui) $f] < 0) && ([lsearch $varPrefs(Printer) $f] < 0) && ([lsearch $varPrefs(Tags) $f] < 0) && ([lsearch $varPrefs(Window) $f] < 0) && ([lsearch $varPrefs(Wrapping) $f] < 0)} {
lappend varPrefs(Miscellaneous) $f
}
}
proc globalOptions {menu item {is_mode ""}} {
global flagPrefs varPrefs maxT tcl_var_procs modifiedVars
if {[string length $is_mode]} {
set args {}
set nvars [llength $item]
lappend args [list "Page 1" $menu [lrange $item 0 [expr ($nvars / 2) - 1]]]
lappend args [list "Page 2" {} [lrange $item [expr ($nvars / 2)] end]]
} else {
if {$item != "flags"} {
return [$item]
}
set args {}
foreach nm [array names flagPrefs] {
lappend args [list $nm $flagPrefs($nm) $varPrefs($nm)]
}
}
set left 20
set height [expr 500 + 60]
set names {}
set maxT 0
foreach arg [lsort $args] {
if {[llength $arg] != 3} {error "Bad structure"}
lappend names [lindex $arg 0]
set flags [lindex $arg 1]
set vars [lindex $arg 2]
append editItems " " $flags " " $vars
append cmd " -n \{[lindex $arg 0]\} " [dialSet $flags $vars]
}
set height [expr $maxT + 30]
set buttons [concat -b OK $left [expr $height-30] [expr $left + 60] [expr $height-10] -b Cancel [expr $left + 100] [expr $height-30] [expr $left + 160] [expr $height-10]]
global blah
set res [eval [concat dialog -w 480 -h $height -t "Preferences:" 60 10 140 30 $buttons [list -m [concat [list [lindex $names 0]] $names] 150 10 255 30] $cmd]]
set changed {}
if {[lindex $res 0]} {
set res [lrange $res 3 end]
if {[string length $is_mode]} {
return $res
}
foreach item $editItems {
set val [lindex $res 0]
set res [lrange $res 1 end]
global $item
if {[set $item] != $val} {
set $item $val
if {[info exists tcl_var_procs($item)]} {
$tcl_var_procs($item) $item
}
lappend modifiedVars $item
}
}
} else {
error "Cancel chosen"
}
}
proc modifyModeFlags {} {
global mode invisibleMode modifiedModeVars
global ${mode}modeVars
global allFlags tcl_var_procs
if {![llength [winNames]]} {
alertnote "No window!"
return
}
set flags {}
set vars {}
if {[info exists ${mode}modeVars]} {
foreach v [lsort [array names ${mode}modeVars]] {
if {[info exists invisibleModeVars($v)]} continue
if {[lsearch $allFlags $v] >= 0} {
lappend flags $v
} else {
lappend vars $v
}
}
set flags [lsort $flags]
set vars [lsort $vars]
if {$mode == "TeX"} {
set res [globalOptions $flags $vars "yes"]
} else {
set res [modeDialog $flags $vars]
}
foreach flag [concat $flags $vars] {
global $flag
set val [lindex $res 0]
set res [lrange $res 1 end]
if {[set $flag] != $val} {
set $flag $val
set ${mode}modeVars($flag) $val
lappend modifiedModeVars [list $flag ${mode}modeVars]
if {[info exists tcl_var_procs($flag)]} {
$tcl_var_procs($flag) $flag
}
}
}
}
}
proc modifyModeString {flag} {
global stringColor mode
regModeKeywords -a -s $stringColor $mode
centerRedraw
}